home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Modules / error0.em < prev    next >
Lisp/Scheme  |  1993-07-15  |  3KB  |  135 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: error0.em
  4. ;; Date: Tue Nov  3 15:02:40 1992
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;
  9.  
  10. (defmodule error0
  11.   (init
  12.    extras0 
  13.    macros0
  14.    defs
  15.    ;; For flush
  16.    streams1 
  17.    )
  18.   ()
  19.  
  20.   
  21.   (deflocal *the-cont* ())
  22.  
  23.   (defgeneric generic-error-printer (c1 c2))
  24.  
  25.   (defmethod generic-error-printer ((c <condition>) cont)
  26.     (flush (standard-error-stream))
  27.     (flush (standard-output-stream))
  28.     (format (standard-error-stream) "Trapped ~a ~a!~%" 
  29.         (if cont "continuable" "non-continuable") 
  30.         (symbol-unbraced-name (class-name (class-of c))))
  31.     (setq *the-cont* cont)
  32.     (mapc (lambda (slot)
  33.         (let ((v ((slot-description-slot-reader slot) c)))
  34.           (if (eq v unbound-slot-value) ()
  35.           (format (standard-error-stream) "  ~a: ~a~%"
  36.               (slot-description-name slot) v))))
  37.       (class-slot-descriptions (class-of c))))
  38.   
  39.   (export generic-error-printer)
  40.   
  41.   (set-print-error-callback generic-error-printer)
  42.  
  43.   (defun !cont x
  44.     (let ((cont *the-cont*))
  45.       (setq *the-cont* nil)
  46.       (if (null x) (cont nil)
  47.     (cont (car x)))))
  48.   
  49.   (export !cont)
  50.  
  51.   (defun std-apply-any (x . args)
  52.     (generic-apply x args))
  53.   
  54.   (defgeneric generic-apply (fn args))
  55.  
  56.   (set-no-function-callback std-apply-any)
  57.  
  58.   (defmethod generic-apply ((x <object>) args)
  59.     (error "invalid operator" <invalid-operator> 'error-value x 'op x 'args args))
  60.  
  61.   (defmethod generic-apply ((gf <generic-function>) args)
  62.     ((generic-discriminator gf) args))
  63.  
  64.   (defmethod generic-apply ((fn <function>) args)
  65.     (apply fn args))
  66.  
  67.   (export generic-apply
  68.       <invalid-operator> 
  69.       invalid-operator-args 
  70.       invalid-operator-op)
  71.  
  72. ;; (1 + 2) => 3
  73. ;;  (defmethod generic-apply ((x <number>) args)
  74. ;;    (if (numberp (car args))
  75. ;;    (call-next-method)
  76. ;;      (apply (car args) (cons x (cdr args)))))
  77.   
  78.   ;; New backtrace. 
  79.   ;; uses nasty internal function.
  80.  
  81.   (export !B)
  82.   (defun !B ()
  83.     (btrace))
  84.   
  85.   (defgeneric print-fn-trace (fn env))
  86.  
  87.   (defmethod print-fn-trace ((fn <i-function>) env)
  88.       (progn (format t "Entered: ~a~%" fn)
  89.          (mapc (lambda (x) 
  90.              (prin "  ")
  91.              (generic-prin (car x) (standard-output-stream))
  92.              (prin ":")
  93.              (generic-prin (cdr x) (standard-output-stream))
  94.              (newline (standard-output-stream)))
  95.            env)))
  96.  
  97.   (defmethod generic-prin ((x <function>) stream)
  98.     (generic-write x stream))
  99.  
  100.   (defmethod print-fn-trace ((x <object>) env)
  101.     (format t "Entered: inst of: ~a~%" (class-of x)))
  102.   
  103.   (defmethod print-fn-trace ((x <bytefunction>) env)
  104.     (format t "Entered: ~a Env: ~a~%" 
  105.         x
  106.         (bytefunction-env x)))
  107.  
  108.   (defmethod print-fn-trace ((x <generic-function>) env)
  109.     (format t "Entered: ~aEnv: ~a~%" x env))
  110.  
  111.   (defmethod print-fn-trace ((x <pair>) env)
  112.     (format t "Entered method chain: ~a~" x))
  113.  
  114.   ;; NB. Can't use labels here (interpreted, the eq test will fail..)
  115.  
  116.   (defun btrace ()
  117.     (btrace-aux (make-vector 3)))
  118.   
  119.   (defun btrace-aux (vect)
  120.     (if (null (get-backtrace-frame vect))
  121.     nil
  122.       (let ((val (vector-ref vect 2)))
  123.     (if (or (eq (car val) btrace)
  124.         (eq (car val) btrace-aux))
  125.         nil
  126.       (progn (print-fn-trace (car val) (cdr val))
  127.          (btrace-aux vect))))))
  128.  
  129.  
  130.      
  131.  
  132.   ;; end module
  133.  
  134.   )
  135.